home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / string / STRING.MAC.f < prev   
Encoding:
Text File  |  1989-03-04  |  44.8 KB  |  1,854 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.5
  3. C---------------------------------------------------------
  4. C
  5. C  ZLEGAL - TEST THE LEGALITY OF A FORTRAN VARIABLE NAME. TWO FORMS
  6. C           OF LEGALITY ARE CHECKED; LEGALITY WITHIN THE STANDARD AND
  7. C           LEGALITY ON THE LOCAL PROCESSOR.
  8. C
  9.       SUBROUTINE ZLEGAL (NAME, STDARD, LOCAL)
  10.  
  11.       INTEGER NAME(*), LENT, I
  12.       INTEGER UPPCH(27), LOWCH(27), DIGCH(11), LGLCH(3), MAIN(6),
  13.      +        BLOCK(11), COMN(8)
  14.       LOGICAL STDARD, LOCAL
  15.  
  16.       INTEGER LENGTH,EQUAL,INDEXX
  17.       EXTERNAL LENGTH,EQUAL,INDEXX
  18.  
  19.       DATA UPPCH/65,66,67,68,69,70,71,72,73,74,75,
  20.      +           76,77,78,79,80,81,82,83,84,85,86,
  21.      +           87,88,89,90,129/
  22.       DATA LOWCH/97,98,99,100,101,102,103,104,105,106,107,
  23.      +           108,109,110,111,112,113,114,115,116,117,118,
  24.      +           119,120,121,122,129/
  25.       DATA DIGCH/48,49,50,51,52,53,54,55,56,57,129/
  26.       DATA LGLCH/36,95,129/
  27.       DATA MAIN/36,77,65,73,78,129/,
  28.      +     BLOCK/36,66,76,79,67,75,68,65,84,65,
  29.      +129/,
  30.      +     COMN/36,67,79,77,77,79,78,129/
  31.  
  32.       LENT = LENGTH(NAME)
  33. C
  34. C  FIRSTLY CHECK AGAINST THE FORTRAN STANDARD
  35. C
  36.       IF (EQUAL(NAME,MAIN).EQ.-2 .OR.
  37.      +    EQUAL(NAME,BLOCK).EQ.-2 .OR.
  38.      +    EQUAL(NAME,COMN).EQ.-2) THEN
  39. C Unnamed main/blockdata/common are all ok.
  40.         STDARD = .TRUE.
  41.         LOCAL = .TRUE.
  42.         RETURN
  43.       END IF
  44.       STDARD = .FALSE.
  45.       IF(LENT .EQ. 0 .OR. LENT .GT. 6) GO TO 1000
  46.       IF(INDEXX(UPPCH, NAME(1)) .EQ. 0) GO TO 1000
  47.       I = 1
  48.    10 CONTINUE
  49.         I = I + 1
  50.         IF(NAME(I) .NE. 129) THEN
  51.           IF(INDEXX(UPPCH, NAME(I)) .NE. 0 .OR.
  52.      +       INDEXX(DIGCH, NAME(I)) .NE. 0) GO TO 10
  53.           GO TO 1000
  54.         ENDIF
  55.  
  56.       STDARD = .TRUE.
  57. C
  58. C  NOW CHECK LOCAL LEGALITY - THIS VERSION WILL ALLOW THE NAME TO
  59. C  BE UP TO 32 CHARACTERS LONG AND TO CONTAIN THE SYMBOLS '$' AND '_'
  60. C
  61.  1000 CONTINUE
  62.       LOCAL = .FALSE.
  63.       IF(LENT .EQ. 0 .OR. LENT .GT. 32) RETURN
  64.       IF(INDEXX(UPPCH, NAME(1)) .EQ. 0 .AND.
  65.      +   INDEXX(LOWCH, NAME(1)) .EQ. 0) RETURN
  66.       I = 1
  67.    20 CONTINUE
  68.         I = I + 1
  69.         IF(NAME(I) .NE. 129) THEN
  70.           IF(INDEXX(UPPCH, NAME(I)) .NE. 0 .OR.
  71.      +       INDEXX(LOWCH, NAME(I)) .NE. 0 .OR.
  72.      +       INDEXX(DIGCH, NAME(I)) .NE. 0 .OR.
  73.      +       INDEXX(LGLCH, NAME(I)) .NE. 0) GO TO 20
  74.           RETURN
  75.         ENDIF
  76.  
  77.       LOCAL = .TRUE.
  78.  
  79.       END
  80. C---------------------------------------------------------
  81. C  XSSSAS BASED ON ISTED/ADDSUB
  82. C
  83. C     CONCATENATE REPLACEMENT STRING FOR MATCHED PATTERN
  84. C
  85.       SUBROUTINE XSSSAS(LIN, FROM, TO, NEW, K, MAXNEW, PATSTR, REPSTR)
  86.  
  87.       INTEGER ADDSET, ZLOWER, ZUPPER
  88.       INTEGER FROM, I, J, JUNK, K, MAXNEW, TO, STARTS, ENDS, C
  89.       INTEGER LIN(*), NEW(*), PATSTR(*), REPSTR(*)
  90.  
  91.       I = 1
  92.  
  93. C     THE STRING 'NEW' ALREADY CONTAINS THE FIRST K-1 CHARACTERS OF 'LIN'
  94. C     THE REPSTRSTITUTE STRING (TAG FIELDS AND ALL) IS PLACED IN NEW INSTEAD
  95. C     OF THE CHARACTERS FROM-TO OF LIN
  96.  
  97. C     LOOP POINT
  98.    10 CONTINUE
  99.  
  100.         IF(REPSTR(I) .EQ. 129) RETURN
  101.  
  102.         IF(REPSTR(I) .EQ. -101) THEN
  103.  
  104.           I  = I + 2
  105.           IF(REPSTR(I) .NE. 0) THEN
  106.             CALL XSSSGT(REPSTR(I), STARTS, ENDS, PATSTR)
  107.           ELSE
  108.             STARTS = FROM
  109.             ENDS = TO
  110.           ENDIF
  111.           J = STARTS
  112.    30     IF(J .GE. ENDS) GOTO 40
  113.             IF(REPSTR(I-1) .EQ. 62) THEN
  114.               C = ZUPPER(LIN(J))
  115.             ELSE IF(REPSTR(I-1) .EQ. 60) THEN
  116.               C = ZLOWER(LIN(J))
  117.             ELSE
  118.               C = LIN(J)
  119.             ENDIF
  120.             JUNK = ADDSET(C, NEW, K, MAXNEW)
  121.             J=J+1
  122.             GOTO 30
  123.    40     CONTINUE
  124.  
  125.         ELSE
  126.  
  127.           JUNK = ADDSET(REPSTR(I), NEW, K, MAXNEW)
  128.  
  129.         ENDIF
  130.  
  131.         I = I + 1
  132.  
  133.       GOTO 10
  134.  
  135.       END
  136. C----------------------------------
  137. C  XISSAM BASED ON ISTED/AMATCH
  138. C
  139. C     FUNCTION TO LOOK FOR A PATTERN MATCH ALONG A LINE
  140. C
  141.       INTEGER FUNCTION XISSAM(LIN, FROM, PATSTR)
  142.  
  143.       INTEGER LIN(*), PATSTR(*)
  144.       INTEGER XISSOM, XISSPS
  145.       INTEGER FROM, I, J, OFFSET, STACK
  146. C
  147. C  XPSSPT - 05 June 1986
  148. C           TIE LIBRARY
  149. C           STRING SUPPLEMENTARY LIBRARY
  150. C
  151. C  Pattern matching parameters
  152. C
  153.  
  154.       INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
  155.      +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
  156.  
  157.       PARAMETER(TAGSYM = 38,     CLOSYM = 42,
  158.      +          CL1SYM = 43,    ANYSYM = 63,
  159.      +          TRANSI = 58,   BOLSYM = 37,
  160.      +          EOLSYM = 36,  OTGSYM = 60,
  161.      +          CTGSYM = 62, CCLSYM = 91,
  162.      +          CCESYM = 93,  MAXPSZ = 256)
  163.  
  164.       STACK = 0
  165.       OFFSET = FROM
  166.       J = 13
  167.  
  168.    10 IF(PATSTR(J) .EQ. 129) GOTO 20
  169.  
  170.       IF(PATSTR(J) .EQ. CLOSYM) THEN
  171.         STACK = J
  172.         J = J + 4
  173.         I = OFFSET
  174.    40   IF(LIN(I) .EQ. 129) GOTO 50
  175.         IF(XISSOM(LIN, I, J, PATSTR) .NE. -3) GOTO 40
  176.    50   CONTINUE
  177.         PATSTR(STACK + 1) = I - OFFSET
  178.         PATSTR(STACK + 3) = OFFSET
  179.         OFFSET = I
  180.  
  181.       ELSE IF(XISSOM(LIN, OFFSET, J, PATSTR) .EQ. -3) THEN
  182.  
  183.    60   IF(STACK .LE. 0) GOTO 30
  184.           IF(PATSTR(STACK + 1) .GT. 0) GOTO 30
  185.           STACK = PATSTR(STACK + 2)
  186.         GO TO 60
  187.  
  188.    30   IF(STACK .LE. 0) THEN
  189.           XISSAM = 0
  190.           RETURN
  191.         ENDIF
  192.  
  193.         PATSTR(STACK+1) = PATSTR(STACK+1) - 1
  194.         J = STACK + 4
  195.         OFFSET = PATSTR(STACK+3) + PATSTR(STACK+1)
  196.       ENDIF
  197.  
  198.       J = J + XISSPS(J, PATSTR)
  199.       GOTO 10
  200.  
  201.    20 CONTINUE
  202.  
  203. C     MATCH FOUND, RETURN POINTER TO END OF MATCH
  204.       XISSAM = OFFSET
  205.  
  206.       END
  207. C==================================
  208. C
  209. C  TAG FIELD ROUTINES
  210. C
  211. C==================================
  212. C  XSSSCT BASED ON ISTED/CLRTAG
  213. C
  214. C  SUBROUTINE TO CLEAR TAG ARRAYS IN PREPERATION FOR PATTERN CREATION
  215. C
  216.       SUBROUTINE XSSSCT(STRING)
  217.  
  218.       INTEGER I, STRING(*)
  219.  
  220. C     CLEAR TAG FIELD START AND END POINTER ARRAYS
  221.       DO 10 I = 2, 11
  222.         STRING(I) = 0
  223.    10 CONTINUE
  224.  
  225. C     SET INITIAL VALUES FOR CURRENT AND NEXT-FREE TAG FIELDS
  226.       STRING(12) = 1
  227.  
  228.       END
  229. C----------------------------------
  230. C  XISSCT BASED ON ISTED/CLSTAG
  231. C
  232. C     FUNCTION TO CLOSE A TAG FIELD AND SAVE THE CURRENT POINTER VALUE
  233. C
  234.       INTEGER FUNCTION XISSCT(POINT, N, STRING)
  235.  
  236.       INTEGER POINT, N, STRING(*)
  237.  
  238.       IF((N .GE. 1) .AND. (N .LE. 9))  THEN
  239.         STRING(N+2) = STRING(N+2)/256*256 + POINT
  240.         XISSCT      = -2
  241.       ELSE
  242.         XISSCT = -1
  243.       ENDIF
  244.  
  245.       END
  246. C----------------------------------
  247. C  XISSNX BASED ON ISTED/NXTTAG
  248. C
  249. C     FUNCTION TO RETURN AN INDEX TO THE NEXT FREE TAG FIELD IDENTIFIER
  250. C
  251.       INTEGER FUNCTION XISSNX(STRING)
  252.  
  253.       INTEGER STRING(*)
  254.  
  255.       IF(STRING(12) .GT. 9) THEN
  256.         XISSNX = -1
  257.  
  258.       ELSE
  259.         XISSNX = STRING(12)
  260.         STRING(12) = STRING(12) + 1
  261.  
  262.       ENDIF
  263.  
  264.       END
  265. C----------------------------------
  266. C  XISSOP BASED ON ISTED/OPNTAG
  267. C
  268. C     FUNCTION TO OPEN A TAG FIELD AND SAVE THE START POSITION
  269. C
  270.       INTEGER FUNCTION XISSOP (POINT, N, STRING)
  271.  
  272.       INTEGER POINT, N, STRING(*)
  273.  
  274.       IF((N .GE. 1) .AND. (N .LE. 9)) THEN
  275. C       SAVE CURRENT POINTER IN TAG FIELD ARRAY
  276.         STRING(N + 2) = POINT * 256
  277.         XISSOP = -2
  278.  
  279.       ELSE
  280. C       ATTEMPT TO OPEN USING AN INVALID TAG FIELD NUMBER
  281.         XISSOP = -1
  282.  
  283.       ENDIF
  284.  
  285.       END
  286. C----------------------------------
  287. C  XISSPR
  288. C
  289. C  FUNCTION TO RETURN THE VALUE OF THE CURRENT TAG FIELD TO
  290. C  BE CLOSED. THE STORAGE LOCATION IN PATSTR IS USED TO HOLD
  291. C  MARKERS TO INDICATE WHICH TAG FIELDS HAVE BEEN CLOSED
  292. C  ALREADY, THESE MARKERS ARE CLEARED ON EXIT FROM ZCOMPP
  293. C
  294.       INTEGER FUNCTION XISSPR(PATSTR)
  295.  
  296.       INTEGER PATSTR(*)
  297.  
  298.       XISSPR = PATSTR(12) - 1
  299.    10 CONTINUE
  300.         IF(XISSPR .LE. 0) THEN
  301.           XISSPR = -1
  302.           RETURN
  303.         ELSE
  304.           IF(PATSTR(XISSPR+2) .NE. 0) THEN
  305.             XISSPR = XISSPR - 1
  306.             GO TO 10
  307.           ELSE
  308.             PATSTR(XISSPR+2) = 1
  309.           ENDIF
  310.         ENDIF
  311.  
  312.       END
  313. C----------------------------------
  314. C  XSSSGT BASED ON ISTED/GETTAG
  315. C
  316.       SUBROUTINE XSSSGT(POINT, START, END, STRING)
  317.  
  318.       INTEGER POINT, START, END, STRING(*)
  319.  
  320.       IF((POINT .GE. 1) .AND. (POINT .LE. 9)) THEN
  321.         END   =  MOD(STRING(POINT+2), 256)
  322.         START =  STRING(POINT+2)/256
  323.  
  324.       ELSE IF(POINT .EQ. 0) THEN
  325.         END   =  MOD(STRING(2), 256)
  326.         START =  STRING(2)/256
  327.  
  328.       ELSE
  329.         START =  0
  330.         END   =  0
  331.  
  332.       ENDIF
  333.  
  334.       END
  335. C----------------------------------
  336. C  XSSFLC
  337. C
  338. C  SAVE THE FIRST AND LAST CHARACTER POSITIONS FOR THE MATCH
  339. C
  340.       SUBROUTINE XSSFLC(START, END, STRING)
  341.  
  342.       INTEGER START, END, STRING(*)
  343.  
  344.       STRING(2) = (START * 256) + END
  345.  
  346.       END
  347. C==================================
  348. C----------------------------------
  349. C  XSSSDO BASED ON ISTED/DODASH
  350. C
  351. C     SUBROUTINE TO EXPAND PATTERN CLASS RANGE
  352. C
  353.       SUBROUTINE XSSSDO(VALID, ARRAY, I, SET, J, MAXSET)
  354.  
  355.       INTEGER XISSEX
  356.       INTEGER ADDSET, INDEXX
  357.       INTEGER I, J, JUNK, K, LIMIT, MAXSET
  358.       INTEGER ARRAY(*), SET(MAXSET), VALID(*)
  359.  
  360.       I = I + 1
  361.       J = J - 1
  362.       LIMIT = INDEXX(VALID, XISSEX(ARRAY, I))
  363.  
  364.       DO 10 K = INDEXX(VALID, SET(J)), LIMIT
  365.         JUNK = ADDSET(VALID(K), SET, J, MAXSET)
  366.    10 CONTINUE
  367.  
  368.       END
  369. C----------------------------------
  370. C  XISSEX BASED ON ISTED/EXPESC
  371. C
  372. C  UN-ESCAPE A SINGLE CHARACTER
  373. C
  374.       INTEGER FUNCTION XISSEX(ARRAY, I)
  375.  
  376.       INTEGER ARRAY(*)
  377.       INTEGER I
  378.  
  379.       IF(ARRAY(I) .EQ. 64) THEN
  380.         I = I + 1
  381.         IF(ARRAY(I) .EQ. 110) THEN
  382.           XISSEX = 10
  383.           RETURN
  384.         ELSE IF(ARRAY(I) .EQ. 116) THEN
  385.           XISSEX = 9
  386.           RETURN
  387.         ENDIF
  388.  
  389.       ENDIF
  390.  
  391.       XISSEX = ARRAY(I)
  392.  
  393.       END
  394. C----------------------------------
  395. C  XSSSFI BASED ON ISTED/FILSET
  396. C
  397. C     SUBROUTINE TO FILL A CHARACTER CLASS SET FOR PATTERN MATCHING
  398. C
  399.       SUBROUTINE XSSSFI(DELIM, ARRAY, I, SET, J, MAXSET)
  400.  
  401.       INTEGER ADDSET, INDEXX, XISSEX
  402.       INTEGER I, J, JUNK, MAXSET, DELIM
  403.       INTEGER ARRAY(*), SET(*), DIGITS(11), LOWALF(27), UPALF(27)
  404.       SAVE
  405.  
  406.       DATA DIGITS /48, 49, 50, 51, 52, 53,
  407.      +             54, 55, 56, 57, 129/
  408.       DATA LOWALF /97, 98, 99, 100, 101, 102, 103, 104, 105,
  409.      +             106, 107, 108, 109, 110, 111, 112, 113, 114,
  410.      +             115, 116, 117, 118, 119, 120, 121, 122, 129/
  411.       DATA UPALF  /65, 66, 67, 68, 69, 70, 71, 72, 73,
  412.      +             74, 75, 76, 77, 78, 79, 80, 81, 82,
  413.      +             83, 84, 85, 86, 87, 88, 89, 90, 129/
  414.  
  415.    10 IF((ARRAY(I) .EQ. DELIM) .OR. (ARRAY(I) .EQ. 129)) RETURN
  416.  
  417.       IF(ARRAY(I) .EQ. 64) THEN
  418.  
  419. C       CHARACTER HAS BEEN ESCAPED
  420.         JUNK = ADDSET(XISSEX(ARRAY, I), SET, J, MAXSET)
  421.       ELSE IF(ARRAY(I) .NE. 45) THEN
  422.  
  423. C
  424.         JUNK = ADDSET(ARRAY(I), SET, J, MAXSET)
  425.       ELSE IF(J .LE. 1 .OR. ARRAY(I+1) .EQ. 129) THEN
  426.  
  427.         JUNK = ADDSET(45, SET, J, MAXSET)
  428.       ELSE IF(INDEXX(DIGITS, SET(J-1)) .GT. 0) THEN
  429.  
  430.         CALL XSSSDO(DIGITS, ARRAY, I, SET, J, MAXSET)
  431.       ELSE IF(INDEXX(LOWALF, SET(J-1)) .GT. 0) THEN
  432.  
  433.         CALL XSSSDO(LOWALF, ARRAY, I, SET, J, MAXSET)
  434.       ELSE IF(INDEXX(UPALF, SET(J-1)) .GT. 0) THEN
  435.  
  436.         CALL XSSSDO(UPALF, ARRAY, I, SET, J, MAXSET)
  437.       ELSE
  438.  
  439.  
  440.         JUNK = ADDSET(45, SET, J, MAXSET)
  441.       ENDIF
  442.  
  443.       I = I + 1
  444.  
  445.       GOTO 10
  446.  
  447.       END
  448. C----------------------------------
  449. C  XISSGC BASED ON ISTED/GETCCL
  450. C
  451. C    FUNCTION TO GET CHARACTER CLASS
  452. C
  453.       INTEGER FUNCTION XISSGC(ARG, I, PAT, J)
  454.  
  455.       INTEGER ARG(*), PAT(*)
  456.       INTEGER ADDSET
  457.       INTEGER I, J, JSTART, JUNK
  458.  
  459. C
  460. C  XPSSPT - 05 June 1986
  461. C           TIE LIBRARY
  462. C           STRING SUPPLEMENTARY LIBRARY
  463. C
  464. C  Pattern matching parameters
  465. C
  466.  
  467.       INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
  468.      +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
  469.  
  470.       PARAMETER(TAGSYM = 38,     CLOSYM = 42,
  471.      +          CL1SYM = 43,    ANYSYM = 63,
  472.      +          TRANSI = 58,   BOLSYM = 37,
  473.      +          EOLSYM = 36,  OTGSYM = 60,
  474.      +          CTGSYM = 62, CCLSYM = 91,
  475.      +          CCESYM = 93,  MAXPSZ = 256)
  476.  
  477.       I = I + 1
  478.  
  479. C     CHECK IF AN INCLUSIVE OR EXCLUSIVE SET IS BEING REQUESTED
  480.       IF(ARG(I) .EQ. 126)  THEN
  481.         JUNK = ADDSET(CCESYM, PAT, J, MAXPSZ)
  482.         I = I + 1
  483.       ELSE
  484.         JUNK = ADDSET(CCLSYM, PAT, J, MAXPSZ)
  485.       ENDIF
  486.  
  487. C     SET UP CLASS ENTRY, INCLUDING MOCK STACK VALUE (INITIALLY 0)
  488.       JSTART = J
  489.       JUNK = ADDSET(0, PAT, J, MAXPSZ)
  490.       CALL XSSSFI(CCESYM, ARG, I, PAT, J, MAXPSZ)
  491.       PAT(JSTART) = J - JSTART - 1
  492.  
  493. C     CHECK TO SEE IF PATTERN FILLED IN OK
  494.       IF(ARG(I) .EQ. CCESYM) THEN
  495.         XISSGC = -2
  496.       ELSE
  497.         XISSGC = -1
  498.       ENDIF
  499.  
  500.       END
  501. C----------------------------------
  502. C  XISSLO BASED ON ISTED/LOCATE
  503. C
  504.       INTEGER FUNCTION XISSLO(C, PAT, OFFSET)
  505.  
  506.       INTEGER PAT(*)
  507.       INTEGER I, OFFSET, C
  508.  
  509.       I = OFFSET + PAT(OFFSET)
  510.  
  511.    10 IF(I .LE. OFFSET) GOTO 20
  512.  
  513.         IF(C .EQ. PAT(I)) THEN
  514.           XISSLO = -2
  515.           RETURN
  516.         ENDIF
  517.         I = I - 1
  518.  
  519.       GOTO 10
  520.  
  521.    20 CONTINUE
  522.       XISSLO = -3
  523.  
  524.       END
  525. C----------------------------------
  526. C  XISSOM  BASED ON ISTED/OMAT
  527. C
  528. C     FUNCTION TO MATCH A SINGLE PATTERN
  529. C
  530.       INTEGER FUNCTION XISSOM(LIN, I, J, PATSTR)
  531.  
  532.       INTEGER LIN(*), PATSTR(*)
  533.       INTEGER XISSOP, XISSCT, ZLOWER, TYPE
  534.       INTEGER STATE1, STATE2
  535.       INTEGER XISSLO
  536.       INTEGER BUMP, I, J, JUNK
  537. C
  538. C  XPSSPT - 05 June 1986
  539. C           TIE LIBRARY
  540. C           STRING SUPPLEMENTARY LIBRARY
  541. C
  542. C  Pattern matching parameters
  543. C
  544.  
  545.       INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
  546.      +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
  547.  
  548.       PARAMETER(TAGSYM = 38,     CLOSYM = 42,
  549.      +          CL1SYM = 43,    ANYSYM = 63,
  550.      +          TRANSI = 58,   BOLSYM = 37,
  551.      +          EOLSYM = 36,  OTGSYM = 60,
  552.      +          CTGSYM = 62, CCLSYM = 91,
  553.      +          CCESYM = 93,  MAXPSZ = 256)
  554.  
  555. C     A NULL STRING DOES NOT MATCH
  556.       XISSOM = -3
  557.  
  558. C     SET INITIAL (INVALID) VALUE FOR POINTER UPDATE
  559.       BUMP = -1
  560.  
  561. C     ORDINARY CHARACTER
  562.       IF(PATSTR(J) .EQ. 97) THEN
  563.         IF(PATSTR(1) .EQ. 1) THEN
  564.           IF(ZLOWER(LIN(I)) .EQ. ZLOWER(PATSTR(J + 1))) BUMP = 1
  565.         ELSE
  566.           IF(LIN(I) .EQ. PATSTR(J + 1)) BUMP = 1
  567.         ENDIF
  568.  
  569. C     BEGINNING OF THE LINE
  570.       ELSE IF(PATSTR(J) .EQ. BOLSYM) THEN
  571.         IF(I .EQ. 1) BUMP = 0
  572.  
  573. C     FREE MATCH (ANY CHARACTER)
  574.       ELSE IF(PATSTR(J) .EQ. 63) THEN
  575.         IF(LIN(I) .NE. 10 .AND. LIN(I) .NE. 129) BUMP = 1
  576.  
  577. C     TRANSITION
  578.       ELSE IF(PATSTR(J) .EQ. TRANSI) THEN
  579.         IF(I .GT. 1) THEN
  580.           STATE1 = TYPE(LIN(I-1))
  581.           STATE2 = TYPE(LIN(I))
  582.           IF(STATE1 .EQ. 2) STATE1 = 1
  583.           IF(STATE2 .EQ. 2) STATE2 = 1
  584.           IF(STATE1 .NE. 1) STATE1 = 48
  585.           IF(STATE2 .NE. 1) STATE2 = 48
  586.           IF(STATE1 .NE. STATE2) BUMP = 0
  587.         ENDIF
  588.  
  589. C     END OF THE LINE
  590.       ELSE IF(PATSTR(J) .EQ. EOLSYM) THEN
  591.         IF((LIN(I) .EQ. 10) .OR. (LIN(I) .EQ. 129)) BUMP = 0
  592.  
  593. C     CHARACTER CLASS
  594.       ELSE IF(PATSTR(J) .EQ. CCLSYM) THEN
  595.         IF(XISSLO(LIN(I), PATSTR, J + 1) .EQ. -2) BUMP = 1
  596.  
  597. C     NEGATED CHARACTER CLASS
  598.       ELSE IF(PATSTR(J) .EQ. CCESYM) THEN
  599.         IF((LIN(I) .NE. 10) .AND. (LIN(I) .NE. 129)
  600.      +    .AND. XISSLO(LIN(I), PATSTR, J + 1) .EQ. -3)  BUMP = 1
  601.  
  602. C     OPEN TAG FIELD
  603.       ELSE IF(PATSTR(J) .EQ. OTGSYM) THEN
  604.         BUMP = 0
  605.         JUNK = XISSOP(I, PATSTR(J+1), PATSTR)
  606.  
  607. C     CLOSE TAG FIELD
  608.       ELSE IF(PATSTR(J) .EQ. CTGSYM) THEN
  609.         BUMP = 0
  610.         JUNK = XISSCT(I, PATSTR(J+1), PATSTR)
  611.  
  612.       ENDIF
  613.  
  614. C     IF BUMP IS NO LONGER -1 THEN A MATCH HAS BEEN FOUND
  615.       IF(BUMP .GE. 0) THEN
  616.         I = I + BUMP
  617.         XISSOM = -2
  618.       ENDIF
  619.  
  620.       END
  621. C----------------------------------
  622. C  XISSPS BASED ON ISTED/PTSIZE
  623. C
  624.       INTEGER FUNCTION XISSPS(N, PATSTR)
  625.  
  626.       INTEGER N, PATSTR(*)
  627. C
  628. C  XPSSPT - 05 June 1986
  629. C           TIE LIBRARY
  630. C           STRING SUPPLEMENTARY LIBRARY
  631. C
  632. C  Pattern matching parameters
  633. C
  634.  
  635.       INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
  636.      +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
  637.  
  638.       PARAMETER(TAGSYM = 38,     CLOSYM = 42,
  639.      +          CL1SYM = 43,    ANYSYM = 63,
  640.      +          TRANSI = 58,   BOLSYM = 37,
  641.      +          EOLSYM = 36,  OTGSYM = 60,
  642.      +          CTGSYM = 62, CCLSYM = 91,
  643.      +          CCESYM = 93,  MAXPSZ = 256)
  644.  
  645.       IF(PATSTR(N) .EQ. 97) THEN
  646.         XISSPS = 2
  647.  
  648.       ELSE IF(PATSTR(N) .EQ. BOLSYM .OR. PATSTR(N) .EQ. EOLSYM
  649.      +        .OR. PATSTR(N) .EQ. 63 .OR. PATSTR(N) .EQ. TRANSI) THEN
  650.         XISSPS = 1
  651.  
  652.       ELSE IF(PATSTR(N) .EQ. CCLSYM .OR. PATSTR(N) .EQ. CCESYM) THEN
  653.         XISSPS = PATSTR(N + 1) + 2
  654.  
  655.       ELSE IF(PATSTR(N) .EQ. CLOSYM) THEN
  656.         XISSPS = 4
  657.  
  658.       ELSE IF(PATSTR(N) .EQ. OTGSYM .OR. PATSTR(N) .EQ. CTGSYM) THEN
  659.         XISSPS = 2
  660.  
  661.       ENDIF
  662.  
  663.       END
  664. C----------------------------------
  665. C  XISSSC BASED ON ISTED/STCLOS
  666. C
  667. C ADD A CLOSURE PATTERN TO THE MATCH PATTERN
  668. C CLOSURE ENTRY SIZE = 4
  669. C              COUNT = 1
  670. C             PREVCL = 2
  671. C              START = 3
  672. C
  673.       INTEGER FUNCTION XISSSC(PAT, J, LASTJ, LASTCL)
  674.  
  675.       INTEGER PAT(*)
  676.       INTEGER ADDSET
  677.       INTEGER J, JP, JT, JUNK, LASTCL, LASTJ
  678. C
  679. C  XPSSPT - 05 June 1986
  680. C           TIE LIBRARY
  681. C           STRING SUPPLEMENTARY LIBRARY
  682. C
  683. C  Pattern matching parameters
  684. C
  685.  
  686.       INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
  687.      +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
  688.  
  689.       PARAMETER(TAGSYM = 38,     CLOSYM = 42,
  690.      +          CL1SYM = 43,    ANYSYM = 63,
  691.      +          TRANSI = 58,   BOLSYM = 37,
  692.      +          EOLSYM = 36,  OTGSYM = 60,
  693.      +          CTGSYM = 62, CCLSYM = 91,
  694.      +          CCESYM = 93,  MAXPSZ = 256)
  695.  
  696.       DO 10 JP = J-1, LASTJ, -1
  697.         JT = JP + 4
  698.         JUNK = ADDSET(PAT(JP), PAT, JT, MAXPSZ)
  699.    10 CONTINUE
  700.  
  701.       J = J + 4
  702.       XISSSC = LASTJ
  703.  
  704.       JUNK = ADDSET(CLOSYM, PAT, LASTJ, MAXPSZ)
  705.       JUNK = ADDSET(0, PAT, LASTJ, MAXPSZ)
  706.       JUNK = ADDSET(LASTCL, PAT, LASTJ, MAXPSZ)
  707.       JUNK = ADDSET(0, PAT, LASTJ, MAXPSZ)
  708.  
  709.       END
  710. C==================================
  711. C
  712. C  USER CALLABLE ROUTINES
  713. C
  714. C==================================
  715. C
  716. C  ZCOMPP  - 9 OCT 86
  717. C            TIE LIBRARY
  718. C            STRING SUPPLEMENTARY LIBRARY
  719. C
  720. C  SET THE SPECIFIED PATTERN INTO THE COMMON BLOCK IN THE
  721. C  FORM USED BY THE PATTERN MATCHING ROUTINE
  722. C
  723.       INTEGER FUNCTION ZCOMPP(STRING, FLAG, PATSTR)
  724.  
  725.       LOGICAL  FLAG
  726.       INTEGER  I, J, JUNK, LASTCL, LASTJ, LJ
  727.       INTEGER  STRING(*), PATSTR(*)
  728.       INTEGER  ADDSET, XISSGC, XISSSC, XISSPR, XISSNX, XISSEX
  729. C
  730. C  XPSSPT - 05 June 1986
  731. C           TIE LIBRARY
  732. C           STRING SUPPLEMENTARY LIBRARY
  733. C
  734. C  Pattern matching parameters
  735. C
  736.  
  737.       INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
  738.      +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
  739.  
  740.       PARAMETER(TAGSYM = 38,     CLOSYM = 42,
  741.      +          CL1SYM = 43,    ANYSYM = 63,
  742.      +          TRANSI = 58,   BOLSYM = 37,
  743.      +          EOLSYM = 36,  OTGSYM = 60,
  744.      +          CTGSYM = 62, CCLSYM = 91,
  745.      +          CCESYM = 93,  MAXPSZ = 256)
  746.  
  747.       CALL XSSSCT(PATSTR)
  748.       PATSTR(1) = 0
  749.       IF(FLAG) PATSTR(1) = 1
  750.  
  751.       J = 13
  752.       LASTJ = 1
  753.       LASTCL = 0
  754.       I = 1
  755.  
  756.    20 IF(STRING(I) .EQ. 129) GO TO 10
  757.  
  758.         LJ = J
  759.  
  760.         IF(STRING(I) .EQ. ANYSYM) THEN
  761.           JUNK = ADDSET(63, PATSTR, J, MAXPSZ)
  762.  
  763.         ELSE IF(STRING(I) .EQ. TRANSI) THEN
  764.           JUNK = ADDSET(TRANSI, PATSTR, J, MAXPSZ)
  765.  
  766.         ELSE IF(STRING(I) .EQ. BOLSYM .AND. I .EQ. 1) THEN
  767.           JUNK = ADDSET(BOLSYM, PATSTR, J, MAXPSZ)
  768.  
  769.         ELSE IF(STRING(I) .EQ. EOLSYM .AND. STRING(I + 1) .EQ. 129) THEN
  770.           JUNK = ADDSET(EOLSYM, PATSTR, J, MAXPSZ)
  771.  
  772.         ELSE IF(STRING(I) .EQ. CCLSYM) THEN
  773.           IF(XISSGC(STRING, I, PATSTR, J) .EQ. -1) GOTO 10
  774.  
  775.         ELSE IF((STRING(I) .EQ. CLOSYM .OR. STRING(I) .EQ. CL1SYM)
  776.      +          .AND. I .GT. 1) THEN
  777.           LJ = LASTJ
  778.           IF(PATSTR(LJ) .EQ. BOLSYM .OR. PATSTR(LJ) .EQ. EOLSYM .OR.
  779.      +       PATSTR(LJ) .EQ. CLOSYM .OR. PATSTR(LJ) .EQ. CL1SYM) GOTO 10
  780.           IF(STRING(I) .EQ. CL1SYM) THEN
  781.             LASTJ = J
  782.    40       IF(LJ .GE. LASTJ) GOTO 30
  783.               JUNK = ADDSET(PATSTR(LJ), PATSTR, J, MAXPSZ)
  784.               LJ = LJ + 1
  785.             GOTO 40
  786.           ENDIF
  787.    30     LASTCL = XISSSC(PATSTR, J, LASTJ, LASTCL)
  788.  
  789.         ELSE IF(STRING(I) .EQ. OTGSYM) THEN
  790.  
  791.           ZCOMPP = XISSNX(PATSTR)
  792.           IF(ZCOMPP .EQ. -1) RETURN
  793.           JUNK = ADDSET(OTGSYM, PATSTR, J, MAXPSZ)
  794.           JUNK = ADDSET(ZCOMPP, PATSTR, J, MAXPSZ)
  795.  
  796.         ELSE IF(STRING(I) .EQ. CTGSYM) THEN
  797.  
  798.           ZCOMPP = XISSPR(PATSTR)
  799.           IF(ZCOMPP .EQ. -1) RETURN
  800.           JUNK = ADDSET(CTGSYM, PATSTR, J, MAXPSZ)
  801.           JUNK = ADDSET(ZCOMPP, PATSTR, J, MAXPSZ)
  802.  
  803.         ELSE
  804.  
  805.           JUNK = ADDSET(97, PATSTR, J, MAXPSZ)
  806.           JUNK = ADDSET(XISSEX(STRING, I), PATSTR, J, MAXPSZ)
  807.  
  808.         ENDIF
  809.  
  810.       LASTJ = LJ
  811.       I = I + 1
  812.       GOTO 20
  813.  
  814.    10 CONTINUE
  815.       CALL XSSSCT(PATSTR)
  816.       ZCOMPP = -2
  817.       IF(I .EQ. 1) RETURN
  818.  
  819.       IF(STRING(I) .NE. 129) THEN
  820.         ZCOMPP = -1
  821.       ELSE IF(ADDSET(129, PATSTR, J, MAXPSZ) .EQ. -3) THEN
  822.         ZCOMPP = -1
  823.       ENDIF
  824.  
  825.       END
  826. C----------------------------------
  827. C
  828. C  ZMATCH  - 9 OCT 86
  829. C            TIE LIBRARY
  830. C            STRING SUPPLEMENTARY LIBRARY
  831. C
  832. C  MATCH THE PATTERN AGAINST THE PROVIDED LINE
  833. C
  834.       INTEGER FUNCTION ZMATCH(STRING, FROM, START, END, PATSTR)
  835.  
  836.       INTEGER  STRING(*), PATSTR(*)
  837.       INTEGER  FROM, START, END, I, N
  838.       INTEGER  XISSAM
  839.  
  840.       ZMATCH = -3
  841.  
  842. C     LOOP ALONG THE LINE UNTIL A MATCH IS FOUND, OR AN EOS IS ENCOUNTERED
  843.       DO 10 I = FROM, 132
  844.  
  845. C       NO MATCH FOUND
  846.         IF(STRING(I) .EQ. 129) RETURN
  847.  
  848.         N = XISSAM(STRING, I, PATSTR)
  849.  
  850.         IF(N .GT. 0) THEN
  851.           ZMATCH = -2
  852.           START  = I
  853.           END    = N - 1
  854.           RETURN
  855.         ENDIF
  856.  
  857.    10 CONTINUE
  858.  
  859.       END
  860. C----------------------------------
  861. C
  862. C  ZREPLS  - 9 OCT 86
  863. C            TIE LIBRARY
  864. C            STRING SUPPLEMENTARY LIBRARY
  865. C
  866. C  SET THE SPECIFIED REPLACEMENT PATTERN INTO THE COMMON BLOCK
  867. C
  868.       INTEGER FUNCTION ZREPLS(STRING, REPSTR)
  869.  
  870.       INTEGER STRING(*), REPSTR(*)
  871.       INTEGER DIGITS(10)
  872.       INTEGER ADDSET, INDEXX, XISSEX
  873.       INTEGER I, J, JUNK, N, POINT, TYPE
  874. C
  875. C  XPSSPT - 05 June 1986
  876. C           TIE LIBRARY
  877. C           STRING SUPPLEMENTARY LIBRARY
  878. C
  879. C  Pattern matching parameters
  880. C
  881.  
  882.       INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
  883.      +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
  884.  
  885.       PARAMETER(TAGSYM = 38,     CLOSYM = 42,
  886.      +          CL1SYM = 43,    ANYSYM = 63,
  887.      +          TRANSI = 58,   BOLSYM = 37,
  888.      +          EOLSYM = 36,  OTGSYM = 60,
  889.      +          CTGSYM = 62, CCLSYM = 91,
  890.      +          CCESYM = 93,  MAXPSZ = 256)
  891.  
  892.       DATA DIGITS /49, 50, 51, 52, 53,
  893.      +             54, 55, 56, 57, 129/
  894.  
  895.       J = 1
  896.       I = 1
  897.    20 IF(STRING(I) .EQ. 129) GO TO 10
  898.  
  899.         IF(STRING(I) .EQ. TAGSYM) THEN
  900.  
  901. C         LOOK FOR A CASE CHANGE REQUEST
  902.           TYPE = 61
  903.           IF(STRING(I + 1) .EQ. 62) THEN
  904.             TYPE = 62
  905.             I = I + 1
  906.           ELSE IF(STRING(I + 1) .EQ. 60) THEN
  907.             TYPE = 60
  908.             I = I + 1
  909.           ENDIF
  910.  
  911.           POINT = I + 1
  912.           N = INDEXX(DIGITS, STRING(POINT))
  913.  
  914.           IF( N .NE. 0) THEN
  915.             JUNK = ADDSET(-101, REPSTR,J, 132)
  916.             JUNK = ADDSET(TYPE, REPSTR, J, 132)
  917.             JUNK = ADDSET(N, REPSTR, J, 132)
  918.             I = I + 1
  919.           ELSE
  920.             JUNK = ADDSET(-101, REPSTR, J, 132)
  921.             JUNK = ADDSET(TYPE, REPSTR, J, 132)
  922.             JUNK = ADDSET(0, REPSTR, J, 132)
  923.             IF(STRING(POINT) .EQ. 48) I = I + 1
  924.           ENDIF
  925.  
  926.         ELSE
  927.  
  928.           JUNK = ADDSET(XISSEX(STRING, I), REPSTR, J, 132)
  929.  
  930.         ENDIF
  931.         I = I + 1
  932.  
  933.       GOTO 20
  934.  
  935.    10 CONTINUE
  936.       IF(ADDSET(129, REPSTR, J, 132) .EQ. -3) THEN
  937.         ZREPLS = -1
  938.       ELSE
  939.         ZREPLS = -2
  940.       ENDIF
  941.  
  942.       END
  943. C----------------------------------
  944. C
  945. C  ZSTRRP  - 9 OCT 86
  946. C            TIE LIBRARY
  947. C            STRING SUPPLEMENTARY LIBRARY
  948. C
  949. C  PERFORM A STRING REPLACEMENT
  950. C
  951.       INTEGER FUNCTION ZSTRRP(STRNG1, STRNG2, GLOBAL, PATSTR, REPSTR)
  952.  
  953.       INTEGER STRNG1(*), STRNG2(*), PATSTR(*), REPSTR(*)
  954.       INTEGER J, JUNK, K, LASTM, M, SUBBED
  955.       LOGICAL GLOBAL
  956.       INTEGER  ADDSET, XISSAM, LENGTH
  957.  
  958.       ZSTRRP = -1
  959.       J = 1
  960.       SUBBED = -3
  961.       LASTM = 0
  962.       K = 1
  963.  
  964.       IF(LENGTH(STRNG1) .GE. K) THEN
  965.    10   CONTINUE
  966.         IF(STRNG1(K) .NE. 129) THEN
  967.           IF(GLOBAL .OR. (SUBBED .EQ. -3)) THEN
  968.             M = XISSAM(STRNG1, K, PATSTR)
  969.           ELSE
  970.             M = 0
  971.           ENDIF
  972.           IF(M .GT. 0 .AND. LASTM .NE. M) THEN
  973.             SUBBED = -2
  974.             CALL XSSFLC(K, M, PATSTR)
  975.             CALL XSSSAS(STRNG1, K, M, STRNG2, J, 132, PATSTR, REPSTR)
  976.             LASTM = M
  977.           ENDIF
  978.           IF((M .EQ. 0) .OR.( M .EQ. K)) THEN
  979.             JUNK = ADDSET(STRNG1(K), STRNG2, J, 132)
  980.             K = K + 1
  981.           ELSE
  982.             K = M
  983.           END IF
  984.           GOTO 10
  985.         END IF
  986.       END IF
  987.       IF(SUBBED .EQ. -2) THEN
  988.         IF(ADDSET(129, STRNG2, J, 132) .EQ. -3) RETURN
  989.         ZSTRRP = -2
  990.       ENDIF
  991.  
  992.       END
  993. C==================================
  994. C
  995. C  OLD USER CALLABLE ROUTINES
  996. C
  997. C==================================
  998. C
  999. C  ZSETP   - 9 OCT 86
  1000. C            TIE LIBRARY
  1001. C            STRING SUPPLEMENTARY LIBRARY
  1002. C
  1003. C  SET THE SPECIFIED PATTERN INTO THE COMMON BLOCK IN THE
  1004. C  FORM USED BY THE PATTERN MATCHING ROUTINE
  1005. C
  1006.       INTEGER FUNCTION ZSETP (STRING, FLAG)
  1007.  
  1008.       LOGICAL  FLAG
  1009.       INTEGER  STRING(*)
  1010.       INTEGER  ZCOMPP
  1011. C
  1012. C  XPSSPT - 05 June 1986
  1013. C           TIE LIBRARY
  1014. C           STRING SUPPLEMENTARY LIBRARY
  1015. C
  1016. C  Pattern matching parameters
  1017. C
  1018.  
  1019.       INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
  1020.      +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
  1021.  
  1022.       PARAMETER(TAGSYM = 38,     CLOSYM = 42,
  1023.      +          CL1SYM = 43,    ANYSYM = 63,
  1024.      +          TRANSI = 58,   BOLSYM = 37,
  1025.      +          EOLSYM = 36,  OTGSYM = 60,
  1026.      +          CTGSYM = 62, CCLSYM = 91,
  1027.      +          CCESYM = 93,  MAXPSZ = 256)
  1028. C
  1029. C  XCSSPT - 9 OCT 86
  1030. C           TIE LIBRARY
  1031. C           STRING SUPPLEMENTARY LIBRARY
  1032. C
  1033. C  PATTERN MATCHING COMMON BLOCK
  1034.  
  1035.       INTEGER  SAVPAT(MAXPSZ),  SAVREP(134)
  1036.  
  1037.       COMMON /XCSSPT/ SAVPAT, SAVREP
  1038.       SAVE
  1039.  
  1040.       ZSETP = ZCOMPP(STRING, FLAG, SAVPAT)
  1041.  
  1042.       END
  1043. C----------------------------------
  1044. C
  1045. C  ZPFIND  - 9 OCT 86
  1046. C            TIE LIBRARY
  1047. C            STRING SUPPLEMENTARY LIBRARY
  1048. C
  1049. C  MATCH THE STORED PATTERN AGAINST THE PROVIDED LINE
  1050. C
  1051.       INTEGER FUNCTION ZPFIND(STRING, FROM, START, END)
  1052.  
  1053.       INTEGER  STRING(*)
  1054.       INTEGER  FROM, START, END, I, N
  1055.       INTEGER  ZMATCH
  1056. C
  1057. C  XPSSPT - 05 June 1986
  1058. C           TIE LIBRARY
  1059. C           STRING SUPPLEMENTARY LIBRARY
  1060. C
  1061. C  Pattern matching parameters
  1062. C
  1063.  
  1064.       INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
  1065.      +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
  1066.  
  1067.       PARAMETER(TAGSYM = 38,     CLOSYM = 42,
  1068.      +          CL1SYM = 43,    ANYSYM = 63,
  1069.      +          TRANSI = 58,   BOLSYM = 37,
  1070.      +          EOLSYM = 36,  OTGSYM = 60,
  1071.      +          CTGSYM = 62, CCLSYM = 91,
  1072.      +          CCESYM = 93,  MAXPSZ = 256)
  1073. C
  1074. C  XCSSPT - 9 OCT 86
  1075. C           TIE LIBRARY
  1076. C           STRING SUPPLEMENTARY LIBRARY
  1077. C
  1078. C  PATTERN MATCHING COMMON BLOCK
  1079.  
  1080.       INTEGER  SAVPAT(MAXPSZ),  SAVREP(134)
  1081.  
  1082.       COMMON /XCSSPT/ SAVPAT, SAVREP
  1083.       SAVE
  1084.  
  1085.       ZPFIND = ZMATCH(STRING, FROM, START, END, SAVPAT)
  1086.  
  1087.       END
  1088. C----------------------------------
  1089. C
  1090. C  ZSETR   - 9 OCT 86
  1091. C            TIE LIBRARY
  1092. C            STRING SUPPLEMENTARY LIBRARY
  1093. C
  1094. C  SET THE SPECIFIED REPLACEMENT PATTERN INTO THE COMMON BLOCK
  1095. C
  1096.       INTEGER FUNCTION ZSETR (STRING)
  1097.  
  1098.       INTEGER STRING(*)
  1099.       INTEGER ZREPLS
  1100. C
  1101. C  XPSSPT - 05 June 1986
  1102. C           TIE LIBRARY
  1103. C           STRING SUPPLEMENTARY LIBRARY
  1104. C
  1105. C  Pattern matching parameters
  1106. C
  1107.  
  1108.       INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
  1109.      +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
  1110.  
  1111.       PARAMETER(TAGSYM = 38,     CLOSYM = 42,
  1112.      +          CL1SYM = 43,    ANYSYM = 63,
  1113.      +          TRANSI = 58,   BOLSYM = 37,
  1114.      +          EOLSYM = 36,  OTGSYM = 60,
  1115.      +          CTGSYM = 62, CCLSYM = 91,
  1116.      +          CCESYM = 93,  MAXPSZ = 256)
  1117. C
  1118. C  XCSSPT - 9 OCT 86
  1119. C           TIE LIBRARY
  1120. C           STRING SUPPLEMENTARY LIBRARY
  1121. C
  1122. C  PATTERN MATCHING COMMON BLOCK
  1123.  
  1124.       INTEGER  SAVPAT(MAXPSZ),  SAVREP(134)
  1125.  
  1126.       COMMON /XCSSPT/ SAVPAT, SAVREP
  1127.       SAVE
  1128.  
  1129.       ZSETR = ZREPLS(STRING, SAVREP)
  1130.  
  1131.       END
  1132. C----------------------------------
  1133. C
  1134. C  ZPREPL  - 9 OCT 86
  1135. C            TIE LIBRARY
  1136. C            STRING SUPPLEMENTARY LIBRARY
  1137. C
  1138. C  PERFORM A STRING REPLACEMENT
  1139. C
  1140.       INTEGER FUNCTION ZPREPL(STRNG1, STRNG2, GLOBAL)
  1141.  
  1142.       INTEGER STRNG1(*), STRNG2(*)
  1143.       LOGICAL GLOBAL
  1144. C
  1145. C  XPSSPT - 05 June 1986
  1146. C           TIE LIBRARY
  1147. C           STRING SUPPLEMENTARY LIBRARY
  1148. C
  1149. C  Pattern matching parameters
  1150. C
  1151.  
  1152.       INTEGER  TAGSYM, CLOSYM, CL1SYM, ANYSYM, TRANSI, MAXPSZ,
  1153.      +         BOLSYM, EOLSYM, OTGSYM, CTGSYM, CCLSYM, CCESYM
  1154.  
  1155.       PARAMETER(TAGSYM = 38,     CLOSYM = 42,
  1156.      +          CL1SYM = 43,    ANYSYM = 63,
  1157.      +          TRANSI = 58,   BOLSYM = 37,
  1158.      +          EOLSYM = 36,  OTGSYM = 60,
  1159.      +          CTGSYM = 62, CCLSYM = 91,
  1160.      +          CCESYM = 93,  MAXPSZ = 256)
  1161. C
  1162. C  XCSSPT - 9 OCT 86
  1163. C           TIE LIBRARY
  1164. C           STRING SUPPLEMENTARY LIBRARY
  1165. C
  1166. C  PATTERN MATCHING COMMON BLOCK
  1167.  
  1168.       INTEGER  SAVPAT(MAXPSZ),  SAVREP(134)
  1169.  
  1170.       COMMON /XCSSPT/ SAVPAT, SAVREP
  1171.       SAVE
  1172.       INTEGER  ZSTRRP
  1173.  
  1174.       ZPREPL = ZSTRRP(STRNG1, STRNG2, GLOBAL, SAVPAT, SAVREP)
  1175.  
  1176.       END
  1177. C----------------------------------
  1178. C
  1179. C  ZSEDID  - 26 JAN 84
  1180. C            TIE LIBRARY
  1181. C            STRING SUPPLEMENTARY LIBRARY
  1182. C
  1183. C  LOOK FOR A SOURCE EMBEDDED DIRECTIVE (SED)
  1184. C
  1185.       INTEGER FUNCTION ZSEDID(LINE, BIND, ID, BODY)
  1186.  
  1187.       INTEGER  BIND, I
  1188.       INTEGER  LINE(*), ID(*), BODY(*)
  1189.       INTEGER  ZLOWER, LENGTH
  1190.       EXTERNAL ZLOWER, SCOPY, SKIPBL, LENGTH
  1191.  
  1192.       ZSEDID = -3
  1193.       BIND   = 32
  1194.  
  1195. C  A SED MUST START WITH A '*' IN COLUMN 1
  1196.       IF(LINE(1) .NE. 42) RETURN
  1197.  
  1198.       I = 2
  1199.       CALL SKIPBL(LINE, I)
  1200.  
  1201.       IF((LINE(I) .NE. 36) .OR. (LINE(I+3) .NE. 36)) RETURN
  1202.       ID(1) = ZLOWER(LINE(I + 1))
  1203.       ID(2) = ZLOWER(LINE(I + 2))
  1204.       ID(3) = 129
  1205.  
  1206.       ZSEDID = -2
  1207.  
  1208.       I = I + 4
  1209.       CALL SKIPBL(LINE, I)
  1210.       CALL SCOPY(LINE, I, BODY, 1)
  1211.  
  1212. C  STRIP OFF TRAILING IN-LINE COMMENTS
  1213.       DO 10 I = 1, 132
  1214.         IF(BODY(I) .EQ. 129) RETURN
  1215.         IF(BODY(I) .EQ. 33) THEN
  1216.           IF(BODY(LENGTH(BODY)) .EQ. 10) THEN
  1217.             BODY(I) = 10
  1218.           ELSE
  1219.             BODY(I) = 129
  1220.           ENDIF
  1221.           BODY(I+1) = 129
  1222.           RETURN
  1223.         ENDIF
  1224.    10 CONTINUE
  1225.  
  1226. C  SOMETHING WRONG, TERMINATE THE BODY
  1227.       BODY(132) = 129
  1228.  
  1229.       END
  1230. C----------------------------------
  1231. C
  1232. C  ZSEDTY  - 27 JAN 84
  1233. C            TIE LIBRARY
  1234. C            STRING SUPPLEMENTARY LIBRARY
  1235. C
  1236. C  IDENTIFY THE TYPE OF THE SED
  1237. C
  1238.       INTEGER FUNCTION ZSEDTY(BODY, TYPE)
  1239.  
  1240.       INTEGER  TYPE, I
  1241.       INTEGER  BODY(*)
  1242.       INTEGER  ZLOWER
  1243.       EXTERNAL ZLOWER
  1244.  
  1245.       TYPE = -1
  1246.       IF(BODY(1) .EQ. 129) GO TO 10
  1247.  
  1248.       I = 1
  1249.       CALL SKIPBL(BODY, I)
  1250.       IF(BODY(I) .EQ. 61) THEN
  1251.         I = I + 1
  1252.         CALL SKIPBL(BODY, I)
  1253.         IF(ZLOWER(BODY(I)    ) .EQ. 111   .AND.
  1254.      +     ZLOWER(BODY(I + 1)) .EQ. 110)  TYPE = -2
  1255.         IF(ZLOWER(BODY(I)    ) .EQ. 111   .AND.
  1256.      +     ZLOWER(BODY(I + 1)) .EQ. 102   .AND.
  1257.      +     ZLOWER(BODY(I + 2)) .EQ. 102)  TYPE = -3
  1258.  
  1259.       ELSE
  1260.         TYPE = 112
  1261.  
  1262.       ENDIF
  1263.  
  1264.    10 CONTINUE
  1265.       ZSEDTY = TYPE
  1266.  
  1267.       END
  1268. C----------------------------------
  1269. C
  1270. C       Z K W L U K  -  Keyword Lookup
  1271. C
  1272. C       STRING:  IST string to match in KEYTBL. This is automatically
  1273. C                converted to lower case.
  1274. C
  1275. C       KEYTBL:  Table of keywords.
  1276. C                format:  KEYTBL(1) = number of keywords in the table
  1277. C                         KEYTBL(2-*) = IST strings separated by eos
  1278. C
  1279. C       result:  1..N = matches keyword number N
  1280. C                0    = ambiguous
  1281. C                err  = no match found
  1282. C
  1283. C       Notes: The keyword table must be sorted into alphabetical order
  1284. C              for the ambiguity detection to work.  If shorter abbrev-
  1285. C              iations are desired, they should be placed at the beginning
  1286. C              of the table.
  1287. C              The keywords in the table *MUST* be in lower case.
  1288. C
  1289.  
  1290.         INTEGER FUNCTION ZKWLUK(STRING,KEYTBL)
  1291.  
  1292.         INTEGER STRING(*),KEYTBL(*)
  1293.  
  1294.         INTEGER I,J,N
  1295.  
  1296.         EXTERNAL ZTOLOW
  1297.  
  1298.         CALL ZTOLOW(STRING)
  1299.         N=1
  1300.         I=1
  1301.  100    J=1
  1302.  200    IF (STRING(J).EQ.KEYTBL(I+J).AND.STRING(J).NE.129) THEN
  1303.             J=J+1
  1304.             GOTO 200
  1305.         END IF
  1306.         IF (STRING(J).EQ.129) THEN
  1307.             IF (KEYTBL(I+J).EQ.129 .OR. N.EQ.KEYTBL(1)) THEN
  1308. C exact match or last keyword (cannot be ambiguous!)
  1309.                 ZKWLUK=N
  1310.                 RETURN
  1311.             END IF
  1312.  300        J=J+1
  1313.             IF (KEYTBL(I+J).NE.129) GOTO 300
  1314.             I=I+J
  1315.             J=1
  1316.  400        IF (STRING(J).EQ.KEYTBL(I+J).AND.STRING(J).NE.129) THEN
  1317.                 J=J+1
  1318.                 GOTO 400
  1319.             END IF
  1320.             IF (STRING(J).EQ.129) THEN
  1321. C ambiguous
  1322.                 ZKWLUK=0
  1323.                 RETURN
  1324.             END IF
  1325. C an unambiguous substring
  1326.             ZKWLUK=N
  1327.             RETURN
  1328.         END IF
  1329.         N=N+1
  1330.         I=I+J
  1331.  500    IF (KEYTBL(I).NE.129) THEN
  1332.             I=I+1
  1333.             GOTO 500
  1334.         END IF
  1335.         IF (N.LE.KEYTBL(1)) GOTO 100
  1336. C no match
  1337.         ZKWLUK=-1
  1338.         END
  1339. C----------------------------------
  1340. C
  1341. C  ZSPLIT  - 27 JAN 84
  1342. C            TIE LIBRARY
  1343. C            STRING SUPPLEMENTARY LIBRARY
  1344. C
  1345. C  SPLIT THE LINE INTO LEFT AND RIGHT HAND SIDES, SEPERATED BY
  1346. C  AN EQUALS SIGN.
  1347. C
  1348.       INTEGER FUNCTION ZSPLIT (LINE, LHS, RHS)
  1349.  
  1350.       INTEGER  I, J, K, SIGN
  1351.       INTEGER  LINE(*), LHS(*), RHS(*)
  1352.       INTEGER  INDEXX, LENGTH
  1353.       EXTERNAL INDEXX, LENGTH
  1354.  
  1355.       ZSPLIT = -1
  1356.       SIGN   = INDEXX(LINE, 61)
  1357.       IF(SIGN .EQ. 0) THEN
  1358.         CALL SCOPY(LINE, 1, LHS, 1)
  1359.         RHS(1) = 129
  1360.         RETURN
  1361.       ENDIF
  1362.  
  1363.       K = 1
  1364.       J = 1
  1365.       CALL SKIPBL(LINE, K)
  1366.  
  1367.       DO 10 I = K, SIGN - 1
  1368.         LHS(J) = LINE(I)
  1369.         J      = J + 1
  1370.    10 CONTINUE
  1371.  
  1372.    20 CONTINUE
  1373.       LHS(J) = 129
  1374.       IF(LHS(J-1) .EQ. 32) THEN
  1375.         J = J - 1
  1376.         GO TO 20
  1377.       ENDIF
  1378.  
  1379.       I = SIGN + 1
  1380.       CALL SKIPBL(LINE, I)
  1381.       CALL SCOPY(LINE, I, RHS, 1)
  1382.       J = LENGTH(RHS) + 1
  1383.  
  1384.    30 CONTINUE
  1385.       IF(RHS(J - 1) .EQ. 32) THEN
  1386.         J      = J - 1
  1387.         RHS(J) = 129
  1388.         GO TO 30
  1389.       ENDIF
  1390.  
  1391.       ZSPLIT = -2
  1392.  
  1393.       END
  1394. C----------------------------------
  1395. C
  1396. C  ZSTRIP  - 26 JAN 84
  1397. C            TIE LIBRARY
  1398. C            STRING SUPPLEMENTARY LIBRARY
  1399. C
  1400. C  STRIP ALL BLANKS FROM THE SPECIFIED STRING.
  1401. C
  1402.       SUBROUTINE ZSTRIP(STRING)
  1403.  
  1404.       INTEGER FROM, TO
  1405.       INTEGER STRING(*)
  1406.  
  1407.       FROM = 1
  1408.       TO   = 1
  1409.       CALL SKIPBL(STRING, FROM)
  1410.  
  1411.       IF(FROM .NE. TO) THEN
  1412.         CALL SCOPY(STRING, FROM, STRING, TO)
  1413.         FROM = TO
  1414.       ENDIF
  1415.  
  1416.    20 CONTINUE
  1417.  
  1418.       IF(STRING(FROM) .EQ. 129) THEN
  1419.         STRING(TO) = 129
  1420.         RETURN
  1421.  
  1422.       ELSE IF(STRING(FROM) .NE. 32) THEN
  1423.         STRING(TO) = STRING(FROM)
  1424.         TO         = TO + 1
  1425.         FROM       = FROM + 1
  1426.  
  1427.       ELSE
  1428.         CALL SKIPBL(STRING, FROM)
  1429.  
  1430.       ENDIF
  1431.  
  1432.       IF(FROM .GT. 134)     RETURN
  1433.       GO TO 20
  1434.  
  1435.       END
  1436. C----------------------------------
  1437. C
  1438. C  ZPACK   - 26 JAN 84
  1439. C            TIE LIBRARY
  1440. C            STRING SUPPLEMENTARY LIBRARY
  1441. C
  1442. C  STRIP ALL UNNECESSARY BLANKS FROM THE SPECIFIED STRING. UNNECESSARY
  1443. C  BLANKS ARE; LEADING BLANKS, TRAILING BLANKS, MULTIPLE BLANKS (THESE
  1444. C  ARE CONVERTED TO SINGLE BLANKS).
  1445. C
  1446.       SUBROUTINE ZPACK (STRING)
  1447.  
  1448.       INTEGER FROM, TO
  1449.       INTEGER STRING(*)
  1450.  
  1451.       FROM = 1
  1452.       TO   = 1
  1453.       CALL SKIPBL(STRING, FROM)
  1454.  
  1455.       IF(FROM .NE. TO) THEN
  1456.         CALL SCOPY(STRING, FROM, STRING, TO)
  1457.         FROM = TO
  1458.       ENDIF
  1459.  
  1460.    20 CONTINUE
  1461.  
  1462.       IF(STRING(FROM) .EQ. 129) THEN
  1463.         STRING(TO) = 129
  1464.         RETURN
  1465.  
  1466.       ELSE IF(STRING(FROM) .NE. 32) THEN
  1467.         STRING(TO) = STRING(FROM)
  1468.         TO         = TO + 1
  1469.         FROM       = FROM + 1
  1470.  
  1471.       ELSE
  1472.         STRING(TO) = 32
  1473.         CALL SKIPBL(STRING, FROM)
  1474.         IF(STRING(FROM) .EQ. 129) STRING(TO) = 129
  1475.         TO         = TO + 1
  1476.  
  1477.       ENDIF
  1478.  
  1479.       IF(FROM .GT. 134)     RETURN
  1480.       GO TO 20
  1481.  
  1482.       END
  1483. C----------------------------------
  1484. C
  1485. C  ZFTOI   - 26 JAN 84
  1486. C            TIE LIBRARY
  1487. C            STRING SUPPLEMENTARY LIBRARY
  1488. C
  1489. C  CONVERT A FORTRAN 77 SUBSTRING TO AN IST STRING
  1490. C
  1491.       SUBROUTINE ZFTOI(LINE1, FROM, TO, LINE2, FLAG)
  1492.  
  1493.       INTEGER         I, J, LIMIT, JUNK, FROM, TO
  1494.       INTEGER         LINE2(*)
  1495.       INTEGER         ZCCTOI
  1496.       LOGICAL         FLAG, SKIP
  1497.       CHARACTER * (*) LINE1
  1498.  
  1499.       EXTERNAL        ZCCTOI
  1500.       INTRINSIC       LEN, MIN
  1501.  
  1502. C  SET THE LIMIT OF THE CONVERSION, NO POINT GOING PAST THE END OF THE STRING
  1503.       LIMIT = MIN(TO, LEN(LINE1))
  1504.       J     = 1
  1505.  
  1506.       SKIP = .FALSE.
  1507.  
  1508. C  CONVERSION LOOP
  1509.       DO 10 I = FROM, LIMIT
  1510.  
  1511. C       CONVERT A CHARACTER
  1512.         LINE2(J) = ZCCTOI(LINE1(I:I), JUNK)
  1513. C
  1514. C       IF THE FLAG IS SET TO INTERPRET FORTRAN 77 STRINGS IN THE
  1515. C       IST MANNER (VARIABLE LENGTH, TERMINATED BY A PERIOD) THEN
  1516. C       IT WILL BE NECESSARY TO CHECK FOR EMBEDDED PERIODS.......
  1517. C
  1518.         IF(FLAG) THEN
  1519.           IF(LINE2(J) .EQ. 46) THEN
  1520.             IF(SKIP) THEN
  1521.               SKIP = .FALSE.
  1522.               GO TO 10
  1523.             ELSE
  1524.               IF(I.EQ.LIMIT) GO TO 20
  1525.               IF(LINE1(I + 1:I + 1) .EQ. '.') THEN
  1526.                 SKIP = .TRUE.
  1527.               ELSE
  1528.                 GO TO 20
  1529.               ENDIF
  1530.             ENDIF
  1531.           ENDIF
  1532.         ENDIF
  1533.         J = J + 1
  1534.  
  1535.    10 CONTINUE
  1536.  
  1537. C  TERMINATE THE IST STRING
  1538.    20 CONTINUE
  1539.       LINE2(J) = 129
  1540.  
  1541.       END
  1542. C----------------------------------
  1543. C
  1544. C  ZITOF   - 26 JAN 84
  1545. C            TIE LIBRARY
  1546. C            STRING SUPPLEMENTARY LIBRARY
  1547. C
  1548. C  CONVERT AN IST SUBSTRING TO A FORTRAN 77 STRING
  1549. C
  1550. C  IF FLAG IS SET .TRUE. THEN THE STRING IS CONVERTED TO AN IST FORMAT
  1551. C  FORTRAN 77 STRING, IE: IT IS TERMINATED BY A PERIOD AND ANY INTERNAL
  1552. C  PERIODS ARE CONVERTED TO DOUBLE PERIODS.
  1553. C
  1554.       SUBROUTINE ZITOF(LINE1, FROM, TO, LINE2, FLAG)
  1555.  
  1556.       INTEGER         I, J, COUNT, FROM, TO, MAXCHR
  1557.       INTEGER         LINE1(*)
  1558.       LOGICAL         LIMIT, FLAG
  1559.       CHARACTER       ZCITOC
  1560.       CHARACTER       CH
  1561.       CHARACTER * (*) LINE2
  1562.       EXTERNAL        ZCITOC
  1563.       INTRINSIC       LEN, MOD
  1564.  
  1565.       J      = 1
  1566.       LIMIT  = .FALSE.
  1567.       MAXCHR = LEN(LINE2)
  1568.  
  1569. C  CONVERSION LOOP
  1570.       DO 10 I = FROM, TO
  1571.  
  1572.         IF(LINE1(I) .EQ. 129) LIMIT = .TRUE.
  1573.  
  1574.         IF(LIMIT) THEN
  1575.           IF(FLAG)  GO TO 15
  1576.           LINE2(J:J) = ' '
  1577.         ELSE
  1578.           LINE2(J:J) = ZCITOC(LINE1(I), CH)
  1579.           IF(FLAG) THEN
  1580.             IF(LINE2(J:J) .EQ. '.') THEN
  1581.               J = J + 1
  1582.               LINE2(J:J) = '.'
  1583.             ENDIF
  1584.           ENDIF
  1585.         ENDIF
  1586.         J = J + 1
  1587.         IF(J .GT. MAXCHR) RETURN
  1588.    10 CONTINUE
  1589.  
  1590.  
  1591.    15 CONTINUE
  1592.       IF(FLAG) THEN
  1593.         J = J - 1
  1594.         IF(J + 2 .GT. MAXCHR) RETURN
  1595.  
  1596.         COUNT = 0
  1597.    20   CONTINUE
  1598.           IF(J - COUNT .LE. 0) GO TO 25
  1599.           IF(LINE2(J-COUNT:J-COUNT) .EQ. '.') THEN
  1600.             COUNT = COUNT + 1
  1601.             GO TO 20
  1602.           ENDIF
  1603.  
  1604.    25   CONTINUE
  1605.         IF(MOD(COUNT, 2) .EQ. 0) THEN
  1606.           LINE2(J + 1:J + 2) = '. '
  1607.         ELSE
  1608.           LINE2(J + 1:J + 2) = '..'
  1609.         ENDIF
  1610.       ENDIF
  1611.  
  1612.       END
  1613. C----------------------------------
  1614. C
  1615. C  ZTOCAP  - 27 JAN 84
  1616. C            TIE LIBRARY
  1617. C            STRING SUPPLEMENTARY LIBRARY
  1618. C
  1619. C  CONVERT AN IST STRING TO UPPER CASE
  1620. C
  1621.       SUBROUTINE ZTOCAP(STRING)
  1622.  
  1623.       INTEGER  I
  1624.       INTEGER  STRING(*)
  1625.       INTEGER  ZUPPER
  1626.       EXTERNAL ZUPPER
  1627.  
  1628.       DO 10 I = 1, 132
  1629.         IF(STRING(I) .EQ. 129) RETURN
  1630.         STRING(I) = ZUPPER(STRING(I))
  1631.    10 CONTINUE
  1632.  
  1633.       END
  1634. C----------------------------------
  1635. C
  1636. C  ZTERM   - 09 FEB 84
  1637. C            TIE LIBRARY
  1638. C            STRING SUPPLEMENTARY LIBRARY
  1639. C
  1640. C  ENSURE THAT A FORTRAN 77 STRING IS TERMINATED WITH AN ODD
  1641. C  NUMBER OF PERIODS (AS REQUIRED BY ZMESS AND ZCHOUT).
  1642. C
  1643.       SUBROUTINE ZTERM(STRING, LENGTH)
  1644.  
  1645.       INTEGER         I, LENGTH, LIMIT
  1646.       CHARACTER * (*) STRING
  1647.  
  1648.       INTRINSIC       LEN, MIN, MOD
  1649.  
  1650. C  SET THE LIMIT OF THE CONVERSION, NO POINT GOING PAST THE END OF THE STRING
  1651.       LIMIT = MIN(LENGTH, LEN(STRING) - 2)
  1652.  
  1653.       DO 10 I = LIMIT, 1, -1
  1654.         IF(STRING(I:I) .NE. '.') GO TO 20
  1655.    10 CONTINUE
  1656.  
  1657.    20 CONTINUE
  1658. C
  1659. C  NOW MAKE SURE THAT THERE ARE AN ODD NUMBER OF TRAILING PERIODS.
  1660. C
  1661.       IF(MOD(LIMIT-I,2) .EQ. 0) THEN
  1662.         STRING(LIMIT+1:LIMIT+2) = '. '
  1663.  
  1664.       ELSE
  1665.         STRING(LIMIT+1:LIMIT+1) = ' '
  1666.  
  1667.       ENDIF
  1668.  
  1669.       END
  1670. C----------------------------------
  1671. C
  1672. C  ZTOLOW  - 27 JAN 84
  1673. C            TIE LIBRARY
  1674. C            STRING SUPPLEMENTARY LIBRARY
  1675. C
  1676. C  CONVERT AN IST STRING TO LOWER CASE
  1677. C
  1678.       SUBROUTINE ZTOLOW(STRING)
  1679.  
  1680.       INTEGER  I
  1681.       INTEGER  STRING(*)
  1682.       INTEGER  ZLOWER
  1683.       EXTERNAL ZLOWER
  1684.  
  1685.       DO 10 I = 1, 132
  1686.         IF(STRING(I) .EQ. 129) RETURN
  1687.         STRING(I) = ZLOWER(STRING(I))
  1688.    10 CONTINUE
  1689.  
  1690.       END
  1691. C----------------------------------
  1692. C
  1693. C  ZTIMST - 26 JAN 84
  1694. C           TIECODE LIBRARY
  1695. C           STRING SUPPLEMENTARY LIBRARY
  1696. C
  1697.       SUBROUTINE ZTIMST(YEAR, MONTH, DAY, HOUR, MINUTE, SECOND, STRING)
  1698.  
  1699.       INTEGER  YEAR, MONTH, DAY,HOUR, MINUTE, SECOND, I, J, TRIP
  1700.       INTEGER  STRING(*), MONS(3, 12),  TEMP(6)
  1701.       INTEGER  ITOC
  1702.       EXTERNAL ITOC
  1703.       SAVE
  1704.  
  1705.       DATA (MONS(I,  1),I=1,3) /74, 65, 78/
  1706.       DATA (MONS(I,  2),I=1,3) /70, 69, 66/
  1707.       DATA (MONS(I,  3),I=1,3) /77, 65, 82/
  1708.       DATA (MONS(I,  4),I=1,3) /65, 80, 82/
  1709.       DATA (MONS(I,  5),I=1,3) /77, 65, 89/
  1710.       DATA (MONS(I,  6),I=1,3) /74, 85, 78/
  1711.       DATA (MONS(I,  7),I=1,3) /74, 85, 76/
  1712.       DATA (MONS(I,  8),I=1,3) /65, 85, 71/
  1713.       DATA (MONS(I,  9),I=1,3) /83, 69, 80/
  1714.       DATA (MONS(I, 10),I=1,3) /79, 67, 84/
  1715.       DATA (MONS(I, 11),I=1,3) /78, 79, 86/
  1716.       DATA (MONS(I, 12),I=1,3) /68, 69, 67/
  1717.  
  1718.  
  1719.       DO 20 I = 1, 20
  1720.         STRING(I) = 32
  1721.    20 CONTINUE
  1722.       STRING(21) = 129
  1723.       STRING(3) = 58
  1724.       STRING(6) = 58
  1725.  
  1726.       IF((YEAR   .LT. 1000) .OR. (YEAR   .GT. 9999)) RETURN
  1727.       IF((MONTH  .LT. 1)    .OR. (MONTH  .GT. 12))   RETURN
  1728.       IF((DAY    .LT. 1)    .OR. (DAY    .GT. 31))   RETURN
  1729.       IF((HOUR   .LT. 0)    .OR. (HOUR   .GT. 23))   RETURN
  1730.       IF((MINUTE .LT. 0)    .OR. (MINUTE .GT. 59))   RETURN
  1731.       IF((SECOND .LT. 0)    .OR. (SECOND .GT. 59))   RETURN
  1732.  
  1733.       TRIP = ITOC(HOUR,  TEMP, 3)
  1734.       IF(TRIP .EQ. 1) THEN
  1735.         STRING(1) = 48
  1736.         STRING(2) = TEMP(1)
  1737.       ELSE
  1738.         STRING(1) = TEMP(1)
  1739.         STRING(2) = TEMP(2)
  1740.       ENDIF
  1741.       TRIP = ITOC(MINUTE, TEMP, 3)
  1742.       IF(TRIP .EQ. 1) THEN
  1743.         STRING(4) = 48
  1744.         STRING(5) = TEMP(1)
  1745.       ELSE
  1746.         STRING(4) = TEMP(1)
  1747.         STRING(5) = TEMP(2)
  1748.       ENDIF
  1749.       TRIP = ITOC(SECOND, TEMP, 3)
  1750.       IF(TRIP .EQ. 1) THEN
  1751.         STRING(7) = 48
  1752.         STRING(8) = TEMP(1)
  1753.       ELSE
  1754.         STRING(7) = TEMP(1)
  1755.         STRING(8) = TEMP(2)
  1756.       ENDIF
  1757.       TRIP = ITOC(DAY, TEMP, 3)
  1758.       IF(TRIP .EQ. 1) THEN
  1759.         STRING(10) = 48
  1760.         STRING(11) = TEMP(1)
  1761.       ELSE
  1762.         STRING(10) = TEMP(1)
  1763.         STRING(11) = TEMP(2)
  1764.       ENDIF
  1765.  
  1766.       DO 10 J = 1, 3
  1767.         STRING(12 + J) = MONS(J, MONTH)
  1768.    10 CONTINUE
  1769.       TRIP = ITOC(YEAR,  TEMP, 5)
  1770.       STRING(17) = TEMP(1)
  1771.       STRING(18) = TEMP(2)
  1772.       STRING(19) = TEMP(3)
  1773.       STRING(20) = TEMP(4)
  1774.  
  1775.       END
  1776. C----------------------------------
  1777. C
  1778. C  ZYESNO  - 06 FEB 84
  1779. C            TIE LIBRARY
  1780. C            STRING SUPPLEMENTARY LIBRARY
  1781. C
  1782. C  LOOK FOR A YES/NO STYLE ANSWER FROM THE USER
  1783. C
  1784.       INTEGER FUNCTION ZYESNO(DEFALT)
  1785.  
  1786.       INTEGER  DEFALT
  1787.       INTEGER  PROMPT(5), ANSWER(134)
  1788.       INTEGER  ZLOWER, GETLIN
  1789.       EXTERNAL ZLOWER, ZPRMPT, GETLIN
  1790.  
  1791.       DATA PROMPT/111,107,63,32,129/
  1792.  
  1793.       ZYESNO = DEFALT
  1794.  
  1795.       CALL ZPRMPT(PROMPT)
  1796.  
  1797.       IF(GETLIN(ANSWER, 0) .GT. 1) THEN
  1798.         IF(ZLOWER(ANSWER(1)) .EQ. 121) ZYESNO = -2
  1799.         IF(ZLOWER(ANSWER(1)) .EQ. 110) ZYESNO = -3
  1800.       ENDIF
  1801.  
  1802.       END
  1803. C----------------------------------
  1804. C
  1805. C  ZSCTOI - 22 MAR 84
  1806. C           STRING SUPPLEMENTARY LIBRARY
  1807. C
  1808. C  SIGNED VERSION OF CTOI
  1809. C
  1810. C  FUNCTION TO CONVERT AN IST FORMAT STRING TO AN
  1811. C  INTEGER. LEADING BLANKS AND TABS ARE IGNORED,
  1812. C  THE NUMBER IS TERMINATED BY THE FIRST NON-DIGIT
  1813. C  CHARACTER FOUND. NEGATIVE NUMBERS ARE
  1814. C  RECOGNIZED. WHITESPACE BETWEEN A MINUS SIGN
  1815. C  AND THE DIGITS IS ALLOWED
  1816. C  THE CHARACTER POINTER IS RETURNED
  1817. C  LOOKING AT THE FIRST NON-DIGIT CHARACTER FOUND.
  1818. C
  1819. C  IF A MINUS SIGN WITHOUT TRAILING DIGITS IS FOUND
  1820. C  THE POINTER IS RETURNED POINTING TO THE MINUS SIGN.
  1821. C
  1822.       INTEGER FUNCTION ZSCTOI(LINE, POINT)
  1823.  
  1824.       INTEGER  POINT, TEMP, VAL
  1825.       INTEGER  LINE(*)
  1826.       INTEGER  CTOI, TYPE
  1827.       LOGICAL  FLAG
  1828.       EXTERNAL CTOI, TYPE
  1829.  
  1830. C     SKIP LEADING BLANKS (AND TABS)
  1831.       CALL SKIPBL(LINE, POINT)
  1832.  
  1833.       FLAG = .FALSE.
  1834.  
  1835.       IF((LINE(POINT) .EQ. 43 ) .OR.
  1836.      +   (LINE(POINT) .EQ. 45)) THEN
  1837.         TEMP = POINT
  1838.         IF(LINE(POINT) .EQ. 45) FLAG = .TRUE.
  1839.         TEMP = TEMP + 1
  1840.         CALL SKIPBL(LINE, TEMP)
  1841.         IF(TYPE(LINE(TEMP)) .NE. 2) THEN
  1842.           ZSCTOI = 0
  1843.           RETURN
  1844.         ENDIF
  1845.         POINT = TEMP
  1846.       ENDIF
  1847.  
  1848.       VAL = CTOI(LINE, POINT)
  1849.       IF(FLAG) VAL = -VAL
  1850.       ZSCTOI = VAL
  1851.  
  1852.       END
  1853.  
  1854.